home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / games / conx.el.z / conx.el
Encoding:
Text File  |  1998-05-21  |  22.3 KB  |  807 lines
  1. ;;; conx.el --- Yet another dissociater
  2.  
  3. ;; Copyright status unknown
  4.  
  5. ;; Author: Jamie Zawinski <jwz@netscape.com>
  6. ;; Keywords: games
  7.  
  8. ;; This file is part of XEmacs.
  9.  
  10. ;; XEmacs is free software; you can redistribute it and/or modify it
  11. ;; under the terms of the GNU General Public License as published by
  12. ;; the Free Software Foundation; either version 2, or (at your option)
  13. ;; any later version.
  14.  
  15. ;; XEmacs is distributed in the hope that it will be useful, but
  16. ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  17. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  18. ;; General Public License for more details.
  19.  
  20. ;; You should have received a copy of the GNU General Public License
  21. ;; along with XEmacs; see the file COPYING.  If not, write to the Free
  22. ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
  23. ;; 02111-1307, USA.
  24.  
  25. ;;; Synched up with: Not in FSF
  26.  
  27. ;;; Commentary:
  28.  
  29. ;;; conx.el: Yet Another Dissociator.
  30. ;;; Original design by Skef Wholey <skef@cs.cmu.edu>;
  31. ;;; ported to Emacs-Lisp by Jamie Zawinski <jwz@netscape.com>, 5-mar-91.
  32. ;;; Run this compiled.  It will be an order of magnitude faster.
  33. ;;;
  34. ;;; Select a buffer with a lot of text in it.  Say M-x conx-buffer
  35. ;;; or M-x conx-region.  Repeat on as many other bodies of text as
  36. ;;; you like.
  37. ;;;
  38. ;;; M-x conx will use the word-frequency tree the above generated
  39. ;;; to produce random sentences in a popped-up buffer.  It will pause
  40. ;;; at the end of each paragraph for two seconds; type ^G to stop it.
  41. ;;;
  42. ;;; M-x conx-init will clear the data structures so you can start
  43. ;;; over.  Note that if you run it twice consecutively on the same
  44. ;;; body of text, word sequences in that buffer will be twice as
  45. ;;; likely to be generated.
  46. ;;;
  47. ;;; Once you have sucked in a lot of text and like the kinds of
  48. ;;; sentences conx is giving you, you can save the internal data
  49. ;;; structures to a file with the M-x conx-save command.  Loading
  50. ;;; this file with M-x conx-load will be a lot faster and easier
  51. ;;; than re-absorbing all of the text files.  Beware that loading a
  52. ;;; saved conx-file clears the conx database in memory.
  53. ;;;
  54. ;;; M-x conx-emit-c will write out C source code which, when compiled,
  55. ;;; will produce a standalone program which generates sentences from
  56. ;;; a copy of the database currently loaded.
  57. ;;;
  58. ;;; Ideas for future improvement:
  59. ;;;
  60. ;;;  o  It would be nice if we could load in more than one saved
  61. ;;;     file at a time.
  62. ;;;
  63. ;;;  o  use it to collect statistics on newsgroup conversations by
  64. ;;;     examining the tree for the most common words and phrases
  65. ;;;
  66. ;;;  o  when replying to mail, insert an X-CONX: header field which
  67. ;;;     contains a sentence randomly generated from the body of the
  68. ;;;     message being replied to.
  69. ;;;
  70. ;;;  o  It could stand to be faster...
  71.  
  72. ;;; Code:
  73. (defconst conx-version "1.6,  6-may-94.")
  74.  
  75. (defvar conx-bounce 10) ; 1/x
  76. (defvar conx-hashtable-size 9923)  ; 9923 is prime
  77. (defconst conx-words-hashtable nil)
  78. (defconst conx-words-vector nil)
  79. (defconst conx-words-vector-fp 0)
  80.  
  81. (defconst conx-last-word nil)
  82. p
  83. (defvar conx-files nil "FYI")
  84.  
  85. (defun conx-init ()
  86.   "Forget the current word-frequency tree."
  87.   (interactive)
  88.   (if (and conx-words-hashtable
  89.        (>= (length conx-words-hashtable) conx-hashtable-size))
  90.       (fillarray conx-words-hashtable 0)
  91.       (setq conx-words-hashtable (make-vector conx-hashtable-size 0)))
  92.   (if conx-words-vector
  93.       (fillarray conx-words-vector nil)
  94.       (setq conx-words-vector (make-vector 1000 nil))) ; this grows
  95.   (setq conx-words-vector-fp 0)
  96.   (setq conx-last-word nil
  97.     conx-files nil))
  98.  
  99. (defun conx-rehash ()
  100.   ;; misnomer; this just grows the linear vector, growing the hash table
  101.   ;; is too hard.
  102.   (message "Rehashing...")
  103.   (let* ((L (length conx-words-vector))
  104.      (v2 (make-vector (+ L L) nil)))
  105.     (while (< 0 L)
  106.       (aset v2 (1- L) (aref conx-words-vector (setq L (1- L)))))
  107.     (setq conx-words-vector v2)
  108.     )
  109.   (message "Rehashing...done"))
  110.  
  111. (defmacro conx-count  (word) (list 'aref word 0))
  112. (defmacro conx-cap    (word) (list 'aref word 1))
  113. (defmacro conx-comma  (word) (list 'aref word 2))
  114. (defmacro conx-period (word) (list 'aref word 3))
  115. (defmacro conx-quem   (word) (list 'aref word 4))
  116. (defmacro conx-bang   (word) (list 'aref word 5))
  117. (defmacro conx-succ   (word) (list 'aref word 6))
  118. (defmacro conx-pred   (word) (list 'aref word 7))
  119. (defmacro conx-succ-c (word) (list 'aref word 8))
  120. (defmacro conx-pred-c (word) (list 'aref word 9))
  121. (defconst conx-length 10)
  122.  
  123. (defmacro conx-make-word ()
  124.   '(copy-sequence '[1 0 0 0 0 0 nil nil 0 0]))
  125.  
  126. (defmacro conx-setf (form val)  ; mind-numbingly simple
  127.   (setq form (macroexpand form (and (boundp 'byte-compile-macro-environment)
  128.                     byte-compile-macro-environment)))
  129.   (cond ((symbolp form) (list 'setq form val))
  130.     ((eq (car form) 'aref) (cons 'aset (append (cdr form) (list val))))
  131.     ((eq (car form) 'cdr) (list 'setcdr (nth 1 form) val))
  132.     ((eq (car form) 'car) (list 'setcar (nth 1 form) val))
  133.     (t (error "can't setf %s" form))))
  134.  
  135. (defmacro conx-push (thing list)
  136.   (list 'conx-setf list (list 'cons thing list)))
  137.  
  138. (defconst conx-most-positive-fixnum (lsh -1 -1)
  139.   "The largest positive integer that can be represented in this emacs.")
  140.  
  141. (defmacro conx-rand (n)
  142.   (list '% (list 'logand 'conx-most-positive-fixnum '(random)) n))
  143.  
  144. (defmacro conx-relate-succ (word related)
  145.   (` (let ((vec (symbol-value (, word))))
  146.        (conx-setf (conx-succ-c vec) (1+ (conx-succ-c vec)))
  147.        (let ((rel (assq (, related) (conx-succ vec))))
  148.      (if rel
  149.          (setcdr rel (1+ (cdr rel)))
  150.          (conx-push (cons (, related) 1) (conx-succ vec)))))))
  151.  
  152. (defmacro conx-relate-pred (word related)
  153.   (` (let ((vec (symbol-value (, word))))
  154.        (conx-setf (conx-pred-c vec) (1+ (conx-pred-c vec)))
  155.        (let ((rel (assq (, related) (conx-pred vec))))
  156.      (if rel
  157.          (setcdr rel (1+ (cdr rel)))
  158.          (conx-push (cons (, related) 1) (conx-pred vec)))))))
  159.  
  160. (defmacro conx-add-word (word)
  161.   (` (let* ((word (, word))
  162.         (fc (aref word 0)))
  163.        (setq word (intern (downcase word) conx-words-hashtable))
  164.        (let ((vec (and (boundp word) (symbol-value word))))
  165.      (if vec
  166.          (conx-setf (conx-count vec) (1+ (conx-count vec)))
  167.        (if (= conx-words-vector-fp (length conx-words-vector))
  168.            (conx-rehash))
  169.        (set word (setq vec (conx-make-word)))
  170.        (aset conx-words-vector conx-words-vector-fp word)
  171.        (setq conx-words-vector-fp (1+ conx-words-vector-fp)))
  172.      (or (< fc ?A) (> fc ?Z)
  173.          (conx-setf (conx-cap vec) (1+ (conx-cap vec)))))
  174.        (if conx-last-word
  175.        (progn
  176.          (conx-relate-succ conx-last-word word)
  177.          (conx-relate-pred word conx-last-word)))
  178.        (setq conx-last-word word))))
  179.  
  180. (defmacro conx-punx (char)
  181.   (` (if conx-last-word
  182.      (let ((char (, char))
  183.            (vec (symbol-value conx-last-word)))
  184.        (cond ((eq char ?\,)
  185.           (conx-setf (conx-comma vec) (1+ (conx-comma vec))))
  186.          ((or (eq char ?\.)
  187.               (eq char ?\;))
  188.           (conx-setf (conx-period vec) (1+ (conx-period vec)))
  189.           (setq conx-last-word nil))
  190.          ((eq char ?\?)
  191.           (conx-setf (conx-quem vec) (1+ (conx-quem vec)))
  192.           (setq conx-last-word nil))
  193.          ((eq char ?\!)
  194.           (conx-setf (conx-bang vec) (1+ (conx-bang vec)))
  195.           (setq conx-last-word nil)))))))
  196.  
  197. (defun conxify-internal ()
  198.   (let (p w)
  199.     (while (not (eobp))
  200.       (skip-chars-forward "^A-Za-z0-9'")
  201.       (while (memq (following-char) '(?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9 ?\'))
  202.     ;; ignore words beginning with digits
  203.     (skip-chars-forward "A-Za-z0-9'")
  204.     (skip-chars-forward "^A-Za-z0-9'"))
  205.       (setq p (point))
  206.       (skip-chars-forward "A-Za-z0-9'")
  207.       (if (= ?\' (preceding-char)) (forward-char -1))
  208.       (if (eq p (point))
  209.       nil
  210.     (setq w (buffer-substring p (point)))
  211.     (if (equal "nil" w)  ; hey, nil is totally magic, this doesn't work!
  212.         nil
  213.       (conx-add-word w)
  214.       (setq n (1+ n))
  215.       (skip-chars-forward " \t\n\r")
  216.       (if (memq (setq p (following-char)) '(?\, ?\. ?\! ?\? ?\;))
  217.           (conx-punx p)))))))
  218.  
  219. ;;;###autoload
  220. (defun conx-buffer ()
  221.   "Absorb the text in the current buffer into the tree."
  222.   (interactive)
  223.   (or conx-words-vector (conx-init))
  224.   (let ((i conx-words-vector-fp)
  225.     (n 0)
  226.     (pm (point-max)))
  227.     (save-excursion
  228.       (goto-char (point-min))
  229.       (save-restriction
  230.     (widen)
  231.     (while (< (setq p (point)) pm)
  232.       (search-forward "\n\n" pm 0)
  233.       (narrow-to-region p (point))
  234.       (goto-char (prog1 p (setq p (point))))
  235.       (conxify-internal)
  236.       (widen)
  237.       (message "%d%%..." (/ (* p 100) (point-max))))))
  238.     (if buffer-file-name
  239.     (setq conx-files (nconc conx-files (list buffer-file-name))))
  240.     (message "%s words, %d unique" n (- conx-words-vector-fp i))))
  241.  
  242. ;;;###autoload
  243. (defun conx-region (p m)
  244.   "Absorb the text in the current region into the tree."
  245.   (interactive "r")
  246.   (save-restriction
  247.     (widen)
  248.     (narrow-to-region p m)
  249.     (conx-buffer)))
  250.  
  251. (defun conx-mail-buffer ()
  252.   "Conxify a buffer in /bin/mail format."
  253.   (interactive)
  254.   (save-excursion
  255.     (goto-char (point-min))
  256.     (skip-chars-forward "\n \t")
  257.     (let ((case-fold-search nil)
  258.       (buffer-file-name nil)
  259.       p p2 p3)
  260.       (or (looking-at "^From ") (error "not in /bin/mail format"))
  261.       (while (not (eobp))
  262.     (search-forward "\n\n" nil 0)
  263.     (setq p (point))
  264.     (search-forward "\nFrom " nil 0)
  265.     (setq p3 (setq p2 (point)))
  266.     ;; don't count ".signature" sections.
  267.     (and (re-search-backward "\n--+\n" nil t)
  268.          (< (count-lines (point) p2) 9)
  269.          (setq p2 (point)))
  270.     (conx-region p (point))
  271.     (goto-char p3)))
  272.     (if buffer-file-name
  273.     (setq conx-files (nconc conx-files (list buffer-file-name))))
  274.     ))
  275.  
  276. ;;; output
  277.  
  278. (defun conx-random-related (count list)
  279.   (let ((foll (if (= 0 count) 0 (conx-rand count)))
  280.     ans)
  281.     (while list
  282.       (if (<= foll (cdr (car list)))
  283.       (setq ans (car (car list))
  284.         list nil)
  285.       (setq foll (- foll (cdr (car list)))
  286.         list (cdr list))))
  287.     ans))
  288.  
  289. (defun conx-random-succ (word)
  290.   (if (= 0 (conx-succ-c (symbol-value word)))
  291.       word
  292.       (let ((next (conx-random-related
  293.             (conx-succ-c (symbol-value word))
  294.             (conx-succ (symbol-value word)))))
  295.     (if (= 0 (conx-rand conx-bounce))
  296.         (conx-random-succ
  297.           (conx-random-related
  298.         (conx-pred-c (symbol-value next))
  299.         (conx-pred (symbol-value next))))
  300.         next))))
  301.  
  302.  
  303. (defun conx-sentence ()
  304.   (or (> conx-words-vector-fp 0)
  305.       (error "no conx data is loaded; see `conx-buffer'."))
  306.   (let* ((word (aref conx-words-vector (conx-rand conx-words-vector-fp)))
  307.      (first-p t)
  308.      (p (point))
  309.      vec punc str)
  310.     (while word
  311.       (setq punc (conx-rand (conx-count (setq vec (symbol-value word)))))
  312.       (if (or first-p
  313.           ;; (< (conx-rand (conx-count vec)) (conx-cap vec))
  314.           (= (conx-count vec) (conx-cap vec))
  315.           )
  316.       (progn
  317.         (setq first-p nil)
  318.         (setq str (symbol-name word))
  319.         (insert (+ (- ?A ?a) (aref str 0)))
  320.         (insert (substring str 1)))
  321.       (insert (symbol-name word)))
  322.       (cond ((< punc (conx-comma vec))
  323.          (insert ", "))
  324.         ((< (setq punc (- punc (conx-comma vec))) (conx-period vec))
  325.          (setq word nil)
  326.          (if (= 0 (conx-rand 5))
  327.          (if (= 0 (conx-rand 4))
  328.              (insert ": ")
  329.              (insert "; "))
  330.          (insert ".  ")))
  331.         ((< (setq punc (- punc (conx-period vec))) (conx-quem vec))
  332.          (setq word nil)
  333.          (insert "?  "))
  334.         ((< (setq punc (- punc (conx-quem vec))) (conx-bang vec))
  335.          (setq word nil)
  336.          (insert "!  "))
  337.         (t
  338.          (insert " ")
  339.          (if (= 0 (conx-succ-c vec)) (setq word nil))))
  340.       (if word
  341.       (setq word (conx-random-succ word))))
  342.     (fill-region-as-paragraph (save-excursion
  343.                 (goto-char p)
  344.                 (beginning-of-line)
  345.                 (point))
  346.                   (point))
  347.     (if (= (preceding-char) ?\n)
  348.     (if (= 0 (conx-rand 4))
  349.         (insert "\n")
  350.       (delete-char -1)
  351.       (insert "  "))))
  352.   nil)
  353.  
  354. ;;;###autoload
  355. (defun conx ()
  356.   "Generate some random sentences in the *conx* buffer."
  357.   (interactive)
  358.   (display-buffer (set-buffer (get-buffer-create "*conx*")))
  359.   (select-window (get-buffer-window "*conx*"))
  360.   (message "type ^G to stop.")
  361.   (while t
  362.     (goto-char (point-max))
  363.     (sit-for (if (= (preceding-char) ?\n) 2 0))
  364.     (conx-sentence)))
  365.  
  366.  
  367. ;;; GNUS interface; grab words from the current message.
  368.  
  369. (defun conx-gnus-snarf ()
  370.   "For use as a gnus-select-article-hook."
  371.   (set-buffer gnus-article-buffer)
  372.   (save-excursion
  373.     (save-restriction
  374.       (widen)
  375.       (goto-char (point-min))
  376.       (search-forward "\n\n" nil t)
  377.       (conx-region (point) (point-max)))))
  378.  
  379. ;;(add-hook 'gnus-select-article-hook 'conx-gnus-snarf)
  380.  
  381. (defun psychoanalyze-conx ()
  382.   "Mr. Random goes to the analyst."
  383.   (interactive)
  384.   (doctor)                ; start the psychotherapy
  385.   (message "")
  386.   (switch-to-buffer "*doctor*")
  387.   (sit-for 0)
  388.   (while (not (input-pending-p))
  389.     (conx-sentence)
  390.     (if (= (random 2) 0)
  391.     (conx-sentence))
  392.     (sit-for 0)
  393.     (doctor-ret-or-read 1)))
  394.  
  395.  
  396. ;;; Saving the database
  397.  
  398. (defun conx-save (file)
  399.   "Save the current CONX database to a file for future retrieval.
  400. You can re-load this database with the \\[conx-load] command."
  401.   (interactive "FSave CONX corpus to file: ")
  402.   (save-excursion
  403.    (let (b)
  404.     (unwind-protect
  405.       (progn
  406.     (set-buffer (setq b (get-buffer-create "*conx-save-tmp*")))
  407.     (delete-region (point-min) (point-max))
  408.     (insert ";;; -*- Mode:Emacs-Lisp -*-\n")
  409.     (insert ";;; This is a CONX database file.  Load it with `conx-load'.\n")
  410.     (if conx-files
  411.         (insert ";;; Corpus: " (mapconcat 'identity conx-files ", ") "\n"))
  412.     (insert ";;; Date: " (current-time-string) "\n\n")
  413.     ;; The file format used here is such a cute hack that I'm going to
  414.     ;; leave it as an excercise to the reader to figure it out.
  415.     (let ((p (point))
  416.           (fill-column 78)
  417.           (fill-prefix "\t")
  418.           (i 0))
  419.       (insert "(!! [\t")
  420.       (while (< i conx-words-vector-fp)
  421.         (prin1 (aref conx-words-vector i) (current-buffer))
  422.         (insert " ")
  423.         (setq i (1+ i)))
  424.       (insert "])\n")
  425.       (fill-region-as-paragraph p (point))
  426.       (insert "\n"))
  427.     (mapatoms (function (lambda (sym)
  428.             (if (not (boundp sym))
  429.             nil
  430.               (insert "\(! ")
  431.               (prin1 sym (current-buffer))
  432.               (insert " ")
  433.               (prin1 (symbol-value sym) (current-buffer))
  434.               (insert "\)\n"))))
  435.           conx-words-hashtable)
  436.     (goto-char (point-min))
  437.     (while (re-search-forward "\\bnil\\b" nil t)
  438.       (replace-match "()"))
  439.     (set-visited-file-name file)
  440.     (save-buffer)))
  441.     (and b (kill-buffer b)))))
  442.  
  443. ;;;###autoload
  444. (defun conx-load (file)
  445.   "Load in a CONX database written by the \\[conx-save] command.
  446. This clears the database currently in memory."
  447.   (interactive "fLoad CONX corpus from file: ")
  448.   (conx-init)
  449.   (fset (intern "!!" conx-words-hashtable)
  450.     (function (lambda (vec)
  451.       (setq conx-words-vector vec
  452.         conx-words-vector-fp (length vec)))))
  453.   (fset (intern "!" conx-words-hashtable)
  454.     (symbol-function 'setq))
  455.   (let ((obarray conx-words-hashtable))
  456.     (load file)))
  457.  
  458.  
  459. ;;; Emitting C code
  460.  
  461. (defun conx-emit-c-data (&optional ansi-p)
  462.   (let ((all '())
  463.     (standard-output (current-buffer))
  464.     (after-change-functions nil) ; turning off font-lock speeds it up x2
  465.     (before-change-functions nil)
  466.     (after-change-function nil)
  467.     (before-change-function nil)
  468.     (float-output-format "%.2f")
  469.     count total total100)
  470.     (or conx-words-hashtable (error "no words"))
  471.     (let ((i 0))
  472.       (mapatoms (function (lambda (x)
  473.                 (if (boundp x)
  474.                 (setq all (cons (cons i x) all)
  475.                       i (1+ i)))))
  476.         conx-words-hashtable))
  477.     (setq all (nreverse all))
  478.     (setq total (* 4 (length all))
  479.       total100 (max 1 (if (featurep 'lisp-float-type)
  480.                   (/ (float total) 100)
  481.                 (/ total 100)))
  482.       count 0)
  483.     (let ((rest all)
  484.       (i 5)
  485.       rest2
  486.       word)
  487.       (insert "static unsigned short D[] = {")
  488.       (while rest
  489.     (setq word (symbol-value (cdr (car rest))))
  490.     (setq rest2 (conx-pred word))
  491.     (setq count (1+ count))
  492.     (while rest2
  493.       (princ (cdr (car rest2))) (insert ",")
  494.       (princ (car (rassq (car (car rest2)) all)))
  495.       (insert ",")
  496.       (setq i (1+ i))
  497.       (cond ((> i 10)
  498.          (insert "\n")
  499.          (setq i 0)))
  500.       (setq rest2 (cdr rest2)))
  501.     (message "Writing C code... %s%%" (/ count total100))
  502.     (setq count (1+ count))
  503.     (setq rest2 (conx-succ word))
  504.     (while rest2
  505.       (princ (cdr (car rest2)))
  506.       (insert ",")
  507.       (princ (car (rassq (car (car rest2)) all)))
  508.       (insert ",")
  509.       (setq i (1+ i))
  510.       (cond ((> i 10)
  511.          (insert "\n")
  512.          (setq i 0)))
  513.       (setq rest2 (cdr rest2)))
  514.     (message "Writing C code... %s%%" (/ count total100))
  515.     (setq count (1+ count))
  516.     (setq rest (cdr rest))))
  517.     (insert "0};\nstatic char T[] = \"")
  518.     (let ((rest all)
  519.       (i 0) (j 20)
  520.       k word)
  521.       (while rest
  522.     (setq word (symbol-name (cdr (car rest))))
  523.     (setq k (1+ (length word))
  524.           i (+ i k)
  525.           j (+ j k 3))
  526.     (cond ((> j 77)
  527.            (insert (if ansi-p "\"\n\"" "\\\n"))
  528.            (setq j (+ k 3))))
  529.     (insert word)        ; assumes word has no chars needing backslashes
  530.     (insert "\\000")
  531.     (message "Writing C code... %s%%" (/ count total100))
  532.     (setq count (1+ count))
  533.     (setq rest (cdr rest))))
  534.     (insert "\";\nstatic struct conx_word words [] = {")
  535.     (let ((rest all)
  536.       (i 0) (j 0)
  537.       cons name word)
  538.       (while rest
  539.     (setq cons (car rest)
  540.           name (symbol-name (cdr cons))
  541.           word (symbol-value (cdr cons)))
  542.     (insert "{") (princ (conx-count word))
  543.     (insert ",") (princ (conx-cap word))
  544.     (insert ",") (princ (conx-comma word))
  545.     (insert ",") (princ (conx-period word))
  546.     (insert ",") (princ (conx-quem word))
  547.     (insert ",") (princ (conx-bang word))
  548.     (if (null (conx-pred word))
  549.         (insert ",0")
  550.       (insert ",")
  551.       (princ i)
  552.       (setq i (+ i (* 2 (length (conx-pred word))))))
  553.     (if (null (conx-succ word))
  554.         (insert ",0,")
  555.       (insert ",")
  556.       (princ i)
  557.       (insert ",")
  558.       (setq i (+ i (* 2 (length (conx-succ word))))))
  559.     (princ (conx-pred-c word)) (insert ",")
  560.     (princ (conx-succ-c word)) (insert ",")
  561.     (princ j)
  562.     (setq j (+ j (length name) 1))
  563.     (insert (if (cdr rest) (if (= 0 (% (car cons) 2)) "},\n" "},") "}"))
  564.     (message "Writing C code... %s%%" (/ count total100))
  565.     (setq count (1+ count))
  566.     (setq rest (cdr rest))
  567.     ))
  568.     (insert "};\n#define conx_bounce ")
  569.     (princ conx-bounce)
  570.     (insert "\n")
  571.     (message "Writing C code... done.")
  572.     ))
  573.  
  574. (defvar conx-c-prolog "\
  575. #if __STDC__
  576. #include <stddef.h>
  577. #include <unistd.h>
  578. extern long random (void);
  579. extern void srandom (int);
  580. extern void abort (void);
  581. #endif
  582. #include <stdio.h>
  583. #include <time.h>
  584.  
  585. struct conx_word {
  586.   unsigned short count;
  587.   unsigned short cap;
  588.   unsigned short comma;
  589.   unsigned short period;
  590.   unsigned short quem;
  591.   unsigned short bang;
  592.   unsigned short pred;
  593.   unsigned short succ;
  594.   unsigned short npred;
  595.   unsigned short nsucc;
  596.   unsigned short text;
  597. };
  598. ")
  599.  
  600. (defvar conx-c-code "\
  601. #define countof(x) (sizeof((x)) / sizeof(*(x)))
  602. #define conx_rand(n) (random()%(n))
  603.  
  604. static struct conx_word *
  605. conx_random_related (count, which_list)
  606.      unsigned short count, which_list;
  607. {
  608.   unsigned short *list = D + which_list;
  609.   int i = 0;
  610.   unsigned short foll = (count == 0 ? 0 : conx_rand (count));
  611.   while (1)
  612.     {
  613.       if (foll <= list [i * 2])
  614.     {
  615.       if ((list [i * 2 + 1]) > countof (words))
  616.         abort ();
  617.       return &words [list [i * 2 + 1]];
  618.     }
  619.       foll -= list [i * 2];
  620.       i++;
  621.     }
  622. }
  623.  
  624. static struct conx_word *
  625. conx_random_succ (word)
  626.      struct conx_word *word;
  627. {
  628.   if (word->nsucc == 0)
  629.     return word;
  630.   else
  631.     {
  632.       struct conx_word *next = conx_random_related (word->nsucc, word->succ);
  633.       if (conx_rand (conx_bounce) != 0)
  634.     return next;
  635.       return conx_random_succ (conx_random_related (next->npred, next->pred));
  636.     }
  637. }
  638.  
  639. static void
  640. conx_sentence ()
  641. {
  642.   static int x = 0;
  643.   struct conx_word *word = 0;
  644.   int first_p = 1;
  645.   int done = 0;
  646.   int count = 0;
  647.   while (!done)
  648.     {
  649.       int punc;
  650.       char *text;
  651.       int L;
  652.       if (word)
  653.     word = conx_random_succ (word);
  654.       else
  655.     word = &words [conx_rand (countof (words))];
  656.       count++;
  657.       punc = conx_rand (word->count);
  658.       text = T + word->text;
  659.       L = strlen (text);
  660.       if (x + L > 70)
  661.     {
  662.       putchar ('\\n');
  663.       x = 0;
  664.     }
  665.       x += L+1;
  666.  
  667.       if (first_p || (word->count == word->cap))
  668.     {
  669.       putchar ((*text >= 'a' && *text <= 'z') ? *text + ('A'-'a') : *text);
  670.       fputs (text+1, stdout);
  671.       first_p = 0;
  672.     }
  673.       else
  674.     fputs (text, stdout);
  675.  
  676.       if (punc < word->comma)
  677.     {
  678.       fputs (\", \", stdout);
  679.       x++;
  680.     }
  681.       else if ((punc -= word->comma) < word->period)
  682.     {
  683.       x++;
  684.       if (count > 120 || conx_rand (5) != 0)
  685.         {
  686.           done = 1;
  687.           fputs (\".  \", stdout);
  688.           x++;
  689.         }
  690.       else
  691.         {
  692.           word = 0;
  693.           if (conx_rand (4) == 0)
  694.         fputs (\": \", stdout);
  695.           else
  696.         fputs (\"; \", stdout);
  697.         }
  698.     }
  699.       else if ((punc -= word->period) < word->quem)
  700.     {
  701.       done = 1;
  702.       fputs (\"?  \", stdout);
  703.       x += 2;
  704.     }
  705.       else if ((punc -= word->quem) < word->bang)
  706.     {
  707.       done = 1;
  708.       fputs (\"!  \", stdout);
  709.       x += 2;
  710.     }
  711.       else
  712.     {
  713.       if (word->nsucc == 0)
  714.         {
  715.           fputs (\".  \", stdout);
  716.           x += 2;
  717.           done = 1;
  718.         }
  719.       else
  720.         putchar (' ');
  721.     }
  722.     }
  723.   if (conx_rand (3) == 0)
  724.     {
  725.       fputs (\"\\n\\n\", stdout);
  726.       x = 0;
  727.     }
  728. }
  729.  
  730. main (argc, argv)
  731.      int argc;
  732.      char **argv;
  733. {
  734.   unsigned int howmany, delay;
  735.   char dummy;
  736.   if (argc == 1)
  737.     {
  738.       howmany = 1;
  739.       delay = 0;
  740.     }
  741.   else if (argc == 2 &&
  742.       1 == sscanf (argv[1], \"%ud%c\", &howmany, &dummy))
  743.     delay = 0;
  744.   else if (argc == 3 &&
  745.        1 == sscanf (argv[1], \"%ud%c\", &howmany, &dummy) &&
  746.        1 == sscanf (argv[2], \"%ud%c\", &delay, &dummy))
  747.     ;
  748.   else
  749.     {
  750.       fprintf (stderr, \"usage: %s [count [delay]]\\n\", argv [0]);
  751.       exit (1);
  752.     }
  753.  
  754.   srandom (time (0));
  755.   if (howmany == 0)
  756.     howmany = ~0;
  757.   while (howmany > 0)
  758.     {
  759.       conx_sentence ();
  760.       fflush (stdout);
  761.       howmany--;
  762.       if (delay) sleep (delay);
  763.     }
  764.   putchar ('\\n');
  765.   exit (0);
  766. }
  767. ")
  768.  
  769. (defun conx-emit-c (file &optional non-ansi-p)
  770.   "Write the current CONX database to a file as C source code.
  771. The generated program will have the same effect as M-x conx,
  772. except that it runs without emacs.
  773.  
  774. With a prefix argument, write K&R C instead of ANSI C.  ANSI is
  775. the default because, without a certain ANSI feature, large databases
  776. will overflow static limits in most K&R preprocessors."
  777.   (interactive "FWrite C file: \nP")
  778.   (find-file file)
  779.   (erase-buffer)
  780.   (let ((buffer-undo-list t))
  781.     (insert conx-c-prolog)
  782.     (if (not non-ansi-p)
  783.     (insert "\n#if !__STDC__\n"
  784.         "error! this file requires an ANSI C compiler\n"
  785.         "#endif\n\n"))
  786.     (conx-emit-c-data (not non-ansi-p))
  787.     (insert conx-c-code))
  788.   (goto-char (point-min)))
  789.  
  790.  
  791. ;;; Reporting stats
  792.  
  793. (defun conx-stats ()
  794.   (set-buffer (get-buffer-create "*conx-stats*"))
  795.   (delete-region (point-min) (point-max))
  796.   (mapatoms (function (lambda (x)
  797.           (or (not (boundp x))
  798.           (progn
  799.             (insert (format "%s" (conx-count (symbol-value x))))
  800.             (insert "\t\t")
  801.             (insert (symbol-name x))
  802.             (insert "\n")))))
  803.         conx-words-hashtable)
  804.   (sort-numeric-fields -1 (point-min) (point-max)))
  805.  
  806. ;;; conx.el ends here
  807.